home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlisp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  5.5 KB  |  206 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlisp.c
  5. * RCS:          $Header: xlisp.c,v 1.5 91/03/24 22:25:04 mayer Exp $
  6. * Description:  xlisp.c - a small implementation of lisp with object-oriented programming
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:02:02 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1987, 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlisp.c,v 1.5 91/03/24 22:25:04 mayer Exp $";
  43.  
  44. #include "xlisp.h"
  45.  
  46. /* define the banner line string */
  47. #define BANNER    "XLISP version 2.1, Copyright (c) 1989, by David Betz"
  48.  
  49. /* global variables */
  50. jmp_buf top_level;
  51.  
  52. /* external variables */
  53. extern LVAL s_stdin,s_evalhook,s_applyhook;
  54. extern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
  55. extern int xltrcindent;
  56. extern int xldebug;
  57. extern LVAL true;
  58. extern char buf[];
  59. extern FILE *tfp;
  60.  
  61. /* external routines */
  62. extern FILE *osaopen();
  63.  
  64. /* main - the main routine */
  65. main(argc,argv)
  66.   int argc; char *argv[];
  67. {
  68.     char *transcript;
  69.     CONTEXT cntxt;
  70.     int verbose,i;
  71.     LVAL expr;
  72.  
  73.     /* setup default argument values */
  74.     transcript = NULL;
  75.     verbose = FALSE;
  76.  
  77.     /* parse the argument list switches */
  78. #ifndef LSC
  79.     for (i = 1; i < argc; ++i)
  80.     if (argv[i][0] == '-')
  81.         switch(argv[i][1]) {
  82.         case 't':
  83.         case 'T':
  84.         transcript = &argv[i][2];
  85.         break;
  86.         case 'v':
  87.         case 'V':
  88.         verbose = TRUE;
  89.         break;
  90.         }
  91. #endif
  92.  
  93.     /* initialize and print the banner line */
  94.     osinit(BANNER);
  95.  
  96.     /* setup initialization error handler */
  97.     xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
  98.     if (setjmp(cntxt.c_jmpbuf))
  99.     xlfatal("fatal initialization error");
  100.     if (setjmp(top_level))
  101.     xlfatal("RESTORE not allowed during initialization");
  102.  
  103.     /* initialize xlisp */
  104.     xlinit();
  105.     xlend(&cntxt);
  106.  
  107.     /* reset the error handler */
  108.     xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
  109.  
  110.     /* open the transcript file */
  111.     if (transcript && (tfp = osaopen(transcript,"w")) == NULL) {
  112.     sprintf(buf,"error: can't open transcript file: %s",transcript);
  113.     stdputstr(buf);
  114.     }
  115.  
  116.     /* load "init.lsp" */
  117.     if (setjmp(cntxt.c_jmpbuf) == 0)
  118.     xlload("init.lsp",TRUE,FALSE);
  119.  
  120.     /* load any files mentioned on the command line */
  121.     if (setjmp(cntxt.c_jmpbuf) == 0)
  122.     for (i = 1; i < argc; i++)
  123.         if (argv[i][0] != '-' && !xlload(argv[i],TRUE,verbose))
  124.         xlerror("can't load file",cvstring(argv[i]));
  125.  
  126.     /* target for restore */
  127.     if (setjmp(top_level))
  128.     xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
  129.  
  130.     /* protect some pointers */
  131.     xlsave1(expr);
  132.  
  133.     /* main command processing loop */
  134.     for (;;) {
  135.  
  136.     /* setup the error return */
  137.     if (setjmp(cntxt.c_jmpbuf)) {
  138.         setvalue(s_evalhook,NIL);
  139.         setvalue(s_applyhook,NIL);
  140.         xltrcindent = 0;
  141.         xldebug = 0;
  142.         xlflush();
  143.     }
  144.  
  145.     /* print a prompt */
  146.     stdputstr("> ");
  147.  
  148.     /* read an expression */
  149.     if (!xlread(getvalue(s_stdin),&expr,FALSE))
  150.         break;
  151.  
  152.     /* save the input expression */
  153.     xlrdsave(expr);
  154.  
  155.     /* evaluate the expression */
  156.     expr = xleval(expr);
  157.  
  158.     /* save the result */
  159.     xlevsave(expr);
  160.  
  161.     /* print it */
  162.     stdprint(expr);
  163.     }
  164.     xlend(&cntxt);
  165.  
  166.     /* clean up */
  167.     wrapup();
  168. }
  169.  
  170. /* xlrdsave - save the last expression returned by the reader */
  171. xlrdsave(expr)
  172.   LVAL expr;
  173. {
  174.     setvalue(s_3plus,getvalue(s_2plus));
  175.     setvalue(s_2plus,getvalue(s_1plus));
  176.     setvalue(s_1plus,getvalue(s_minus));
  177.     setvalue(s_minus,expr);
  178. }
  179.  
  180. /* xlevsave - save the last expression returned by the evaluator */
  181. xlevsave(expr)
  182.   LVAL expr;
  183. {
  184.     setvalue(s_3star,getvalue(s_2star));
  185.     setvalue(s_2star,getvalue(s_1star));
  186.     setvalue(s_1star,expr);
  187. }
  188.  
  189. /* xlfatal - print a fatal error message and exit */
  190. xlfatal(msg)
  191.   char *msg;
  192. {
  193.     oserror(msg);
  194.     wrapup();
  195. }
  196.  
  197. /* wrapup - clean up and exit to the operating system */
  198. wrapup()
  199. {
  200.     if (tfp)
  201.     osclose(tfp);
  202.     osfinish();
  203.     exit(0);
  204. }
  205.  
  206.